;;************************************************************************
;; graphic0.lsp 
;; contains code for revised dialog-proto, window-proto,
;; graph-window-proto and graph-proto methods 
;; and new variable buttons
;; copyright (c) 1991-99 by Forrest W. Young
;;************************************************************************

(defun pointplot (varlist &rest args)
  (let* ((nvar (length varlist))
        (plot (case nvar
                (1         (apply #'boxplot      varlist args))
                (2         (apply #'scatterplot  varlist args))
                (3         (apply  #'spinplot    varlist args))
                ((4 5)     (apply #'scatmat      varlist args))
                ((6 7 8 9) (apply #'tourplot     varlist args))
                (t (error-message "There cannot be more than 9 variables.")))))
    plot))


(defmeth list-item-proto :item-list ()
  (coerce (send self :slot-value 'list-data) 'list))
 

;;************************************************************************
;; dialog-proto methods
;;************************************************************************

(defmeth dialog-proto :install-plot-help-item ()
  )

(defmeth dialog-proto :remove-plot-help-item ()
  )

;;************************************************************************
;; graph-window-proto methods
;;************************************************************************

(defmeth graph-window-proto :draw-color-bitmap (color-matrix i j &optional color-mask)
"Args: rgb-matrix i j &optional mask-matrix
Draws a color bitmap derived from color-matrix whose upper-left corner is at pixel i and j. Color mask not implemented. Elements of color matrix must be a lists of three numbers between 0 and 1, inclusive, indicating the amount of each of the rgb colors."
  (let* ((ni (array-dimension color-matrix 0))
         (nj (array-dimension color-matrix 1))
         )
    (dotimes (i ni)
             (dotimes (j nj)
                      (setf rgb (aref color-matrix ii j))
                      (apply #'make-color 'bitmap-bit-color rgb)
                      (send w :draw-color 'bitmap-bit-color)
                      (send w :draw-point 
                            (+ (* row nj) i) 
                            (+ (* col nj) j))))
    t))

;(send graph-window-proto :add-slot 'showing)

;(defmeth graph-window-proto :linked (&optional (link nil set)))

(defmeth graph-window-proto :do-timed-idle (timed-out?))

(defmeth graph-window-proto :do-time ())

(defmeth graph-window-proto :draw-rect (x y w h)
  (let ((dc (send self :draw-color)))
    (send self :draw-color (send self :back-color))
    (send self :paint-rect x y w h)
    (send self :draw-color dc)
    (send self :frame-rect x y w h)))


(defmeth graph-window-proto :make-close-menu (&optional items)
  (send self :add-slot 'close-menu)
  (defmeth self :close-menu (&optional (objid nil set))
    (if set (setf (slot-value 'close-menu) objid))
    (slot-value 'close-menu))
  (let* ((menu (send menu-proto :new "Close PopUp")))
    (apply #'send menu :append-items (if items items
              (progn
                (send menu-item-proto :new "Close (Discard)"
                     :action #'(lambda () (send window :remove)))
                (send menu-item-proto :new "Minimize (Save for Later)"
                     :action #'(lambda () (send window :hide-window)))
                (send dash-item-proto :new)
                (send menu-item-proto :new "Exit (Quit ViSta Session)" 
                     :action #'vista-exit))))
    (defmeth self :close ()
      (send (send self :close-menu)
            :popup (- (first (send self :size)) 20) -20 self))
    (send self :close-menu menu)
    (send menu :install)
    menu))

(defmeth graph-window-proto :point-labels (&optional (labels nil set))
"Message args: (&optional logical)
 Sets or retrieves point labels"
  (unless (send self :has-slot 'point-labels) 
          (send self :add-slot 'point-labels))
  (if set (setf (slot-value 'point-labels) labels))
  (slot-value 'point-labels))


(defmeth graph-window-proto :showing (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the window is showing."
  (unless (send self :has-slot 'showing) 
          (send self :add-slot 'showing))
  (if set (setf (slot-value 'showing) logical))
  (slot-value 'showing))

(defmeth graph-window-proto :show-window ()
  (call-next-method)
  (if (send self :has-slot 'showing)
      (send self :showing t)
      (send self :add-slot 'showing t)))

(defmeth graph-window-proto :hide-window ()
  (call-next-method)
  (if (send self :has-slot 'showing)
      (send self :showing nil)
      (send self :add-slot 'showing nil)))

(defmeth graph-window-proto :remove ()
  (call-next-method)
  (if (send self :has-slot 'showing)
      (send self :showing nil)
      (send self :add-slot 'showing nil)))


#| TOP-MOST METHODS |#

;NOTE THAT (SEND * :TOP-MOST) ALWAYS REPORTS NIL REGARDLESS OF STATE,
;BUT THAT  (SEND * :TOP-MOST T) AND (SEND * :TOP-MOST NIL) SET AND REPORT CORRECTLY
;SO HAVE ADDED SLOT TOP-MOST-STATE TO KEEP TRACK OF STATE

(defmeth graph-window-proto :top-most-state (&optional (logical nil set))
"Args: (&optional logical)
Slot for top-most method (which does not have a slot) that correctly remembers top-most state. Note that (send * :top-most) always reports that top-most is NIL regardless of actual state, but that (send * :top-most t) and (send * :top-most nil) set and report the correctly."
  (unless (send self :has-slot 'top-most-state)
          (send self :add-slot 'top-most-state))
  (if set (setf (slot-value 'top-most-state) logical))
  (slot-value 'top-most-state))
  
(defmeth graph-window-proto :always-on-top (&optional (logical nil set))
"Args: (&optional logical)
Sets and reports top-most state correctly. Note that (send * :top-most) always reports that top-most is NIL regardless of actual state, but that (send * :top-most t) and (send * :top-most nil) set and report the correctly."
  (unless (send self :has-slot 'top-most-state)
          (send self :add-slot 'top-most-state))
  (if set (setf (slot-value 'top-most-state) logical))
  (cond 
    (set 
      (send self :top-most logical)
      (send self :redraw))
    (t
      (send self :top-most-state)))
  )

#|
(defmeth graph-window-proto :top-most (&optional (logical nil set))
"Args: (&optional logical)
Sets and reports top-most state correctly. Note that before this modification (send * :top-most) always reports that top-most is NIL regardless of actual state, but that (send * :top-most t) and (send * :top-most nil) set and report the correctly. Uses the top-most-state slot since cannot access top-most slot correctly"
  (unless (send self :has-slot 'top-most-state)
          (send self :add-slot 'top-most-state))
  (if set (setf (slot-value 'top-most-state) logical))
  (slot-value 'top-most-state))
|#

(defmeth graph-window-proto :toggle-top-most (&optional (top nil top?))
"Args: (&optional top)
Sets window to be or not to be on top when top is T or NIL, or toggles window top-most state if not specified."
  (send self :always-on-top (if top? top (not (send self :always-on-top)))))

(defmeth graph-window-proto :switch-top-most ()
"Arg: none
Toggles window top-most state."
  (send self :always-on-top (not (send self :always-on-top))))


#| ZOOM METHODS |#


(defmeth graph-window-proto :toggle-zoom (&optional (zoom nil zoom?))
  (send self :zoom-zip (if zoom? zoom (not (send self :zoom-zip))))
  (send self :zoom-state (send self :zoom-zip)))


(defmeth graph-window-proto :switch-zoom-state ()
  (send self :zoom-zip (not (send self :zoom-zip)))
  (send self :zoom-state (send self :zoom-zip)))


(defmeth graph-window-proto :restore-location (&optional (xy-list nil set))
"Message args: (&optional logical)
 Sets or retrieves the location to which the window should be restored when it is unzoomed (restored)"
  (unless (send self :has-slot 'restore-location)
          (send self :add-slot 'restore-location))
  (if set (setf (slot-value 'restore-location) xy-list))
  (slot-value 'restore-location))

(defmeth graph-window-proto :restore-size (&optional (wh-list nil set))
"Message args: (&optional logical)
 Sets or retrieves the location to which the window should be restored when it is unzoomed (restored)"
  (unless (send self :has-slot 'restore-size)
          (send self :add-slot 'restore-size))
  (if set (setf (slot-value 'restore-size) wh-list))
  (slot-value 'restore-size))


(defmeth graph-window-proto :zoom-state (&optional (logical nil set))
"Args: (&optional logical)
Remembers zoom state."
  (unless (send self :has-slot 'zoom-state)
          (send self :add-slot 'zoom-state))
  (if set (setf (slot-value 'zoom-state) logical))
  (slot-value 'zoom-state))


(defmeth graph-window-proto :zoom-zip (&optional (state nil used?))
  (cond
    ((not used?) 
     (send self :zoom-state))
    (state 
     (unless (send self :zoom-state)
             (send self :restore-location (send self :location))
             (send self :restore-size (send self :size))
             (send self :restore-pop-state (send self :pop-state)))
     (send self :pop-put t)
     (send self :frame-location 1 1)
     (apply #'send self :frame-size (effective-screen-size))
     (send self :zoom-state t))
    (t
     (when (send self :zoom-state)
           (apply #'send self :location (send self :restore-location))
           (apply #'send self :size (send self :restore-size))
           (send self :pop-put (send self :restore-pop-state)))
     (send self :zoom-state nil)
     )))


#| POP-OUT METHODS |#


(defmeth graph-window-proto :toggle-pop-state (&optional (pop nil pop?))
  (send self :pop-put (if pop? pop (not (send self :pop-put))))
  (send self :pop-state (send self :pop-put)))


(defmeth graph-window-proto :switch-pop-state ()
  (send self :pop-put (not (send self :pop-put)))
  (send self :pop-state (send self :pop-put)))

(defmeth graph-window-proto :pop-state (&optional (logical nil set))
"Args: (&optional logical)
Remembers pop state."
  (unless (send self :has-slot 'pop-state)
          (send self :add-slot 'pop-state))
  (if set (setf (slot-value 'pop-state) logical))
  (slot-value 'pop-state))


(defmeth graph-window-proto :pop-put (&optional (state nil used?))
  (cond
    ((not used?) 
     (send self :pop-state))
    (state
     (unless (send self :pop-state)
             (send self :restore-location (send self :location))
             (send self :restore-size (send self :size))
             (send self :pop-out t)
             (send self :pop-state t)
             ))
    (t
     (when (send self :pop-state)
           (send self :pop-out nil)
           (apply #'send self :location (send self :restore-location))
           (apply #'send self :size (send self :restore-size))
           (send self :pop-state nil)))
     ))
     

(defmeth graph-window-proto :restore-pop-state (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves the popped-out state to which the window should be restored when it is unzoomed (restored)"
  (unless (send self :has-slot 'restore-pop-state)
          (send self :add-slot 'restore-pop-state))
  (if set (setf (slot-value 'restore-pop-state) logical))
  (slot-value 'restore-pop-state))

#| FRONT-WINDOW, SELECT-WINDOW and ACTIVE-WINDOW METHODS |#

(defmeth window-proto :select-window ()
     (send self :top-most t)
     (send self :top-most nil))

;fwy changed from this
(defmeth graph-window-proto :front-window ()
  (send self :show-window)
  (send self :top-most t)
  (send self :top-most nil))

;to this
(defmeth graph-window-proto :front-window ()
  (send self :show-window)
  (when (not (send self :top-most))
        (send self :top-most t)
        (send self :top-most nil))
  (send self :top-most))

;to this (dec 2002)
(defmeth graph-window-proto :front-window ()
"Args: none
makes window the front-window. returns t"
  (send self :show-window)
  (let ((in-top (send self :top-most)))
    (send self :top-most t)
    (when (not in-top)
          (send self :top-most nil))
    t))


;fwy added dec 2002
(defmeth graph-window-proto :active-window ()
"Args: none
Activates window without changing top-bottom position"
  (send self :top-most (send self :top-most))
  (send self :bottom-most (send self :bottom-most))
  t)

#|these definitions appear in vista1.lsp
(defmeth *listener* :active-window ()
  (send *listener* :pop-out t)
  (send *listener* :pop-out nil)
  (send *desktop-container* :active-window))

(defmeth *workmap* :active-window ()
  (send self :top-most (send self :top-most))
  (send self :bottom-most (send self :bottom-most))
  (send *desktop-container* :active-window))

(defmeth *selector* :active-window ()
  (send self :top-most (send self :top-most))
  (send self :bottom-most (send self :bottom-most))
  (send *desktop-container* :active-window))
|#

;;************************************************************************
;; window-proto methods
;;************************************************************************


(defmeth window-proto :add-plot-help-item  (&optional (title))
  (let* ((g self)
         (title2 (if title title (send g :title)))
#+containers
         (m1 (send menu-item-proto :new (if title2 title2 "PlotHelp")
                   :action '(lambda ()
                              (send (send self :slot-value 'plot-obj) :plot-help))))
         (m (send menu-item-proto :new (if title2 title2 "PlotHelp")
                  :action '(lambda ()
                      (send (send self :slot-value 'plot-obj) :plot-help)))))
    (send m :add-slot 'plot-obj g)
    (send g :add-slot 'plot-help-menu m)
    (unless (send g :has-slot 'spreadplot-object)
            (send g :add-slot 'spreadplot-object)
            (defmeth g :spreadplot-object (&optional (obj nil set))
              (if set (setf (slot-value 'spreadplot-object) obj))
              (slot-value 'spreadplot-object)))
#+containers
    (when (and *current-spreadplot* (send g :spreadplot-object))
          (send (send (send g :spreadplot-object) :menu) :append-items m))
    (send *help-menu* :append-items m1)
    (defmeth g :remove ()
      (send g :remove-plot-help-item)
      (call-next-method))
    m))

(defmeth window-proto :remove-plot-help-item ()
  (when (send self :has-slot 'plot-help-menu)
        (let* ((item (send self :slot-value 'plot-help-menu))
               (menu))
          (when item (send item :menu)
                (when menu (send menu :delete-items item))))))

(defmeth window-proto :install-plot-help-item ()
  (when (not (send self :has-slot 'plot-help-menu))
        (send self :add-plot-help-item))
  (send *help-menu* :append-items (send self :slot-value 'plot-help-menu)))

(defmeth window-proto :install-plot-help-item ()
  (if (send self :has-slot 'plot-help-menu)
      (send *help-menu* :append-items (send self :slot-value 'plot-help-menu))
      (send self :add-plot-help-item)))

;;************************************************************************
;; graph-proto methods
;;************************************************************************



    
(defmeth graph-proto :content-only (&optional (logical nil set))
  (unless (send self :has-slot 'content-only )
          (send self :add-slot 'content-only ))
  (if set (setf (slot-value 'content-only) logical))
  (slot-value 'content-only))

(defmeth graph-proto :statistical-object (&optional (obj nil set))
  (unless (send self :has-slot 'statistical-object)
          (send self :add-slot 'statistical-object))
  (if set (setf (slot-value 'statistical-object) obj))
  (slot-value 'statistical-object))

(defmeth graph-proto :overlays (&optional (obj nil set))
  (if set (setf (slot-value 'overlays) obj))
  (slot-value 'overlays))

(defmeth graph-proto :data-object (&optional (objid nil set))
"Args: (&optional objid) data-object slot."
  (unless (send self :has-slot 'data-object)
          (send self :add-slot 'data-object))
  (if set (setf (slot-value 'data-object) objid))
  (slot-value 'data-object))
  

(defmeth graph-proto :do-nothing (x y m1 m2)); used by do-nothing cursor

(defmeth graph-window-proto :find-again ());prevents edit menu item error

;fwy added following modification of Luke's method 4/18/00

(defmeth graph-proto :scale-type (&optional (new nil set) &key (draw t))
"Method args: (&optional new)
Sets or returns scale type."
  (when set
        (case new
          (centroid-fixed
           (setf (slot-value 'scale-type) 'fixed)
           (send self :adjust-to-data :draw nil))
          (centroid-variable
           (setf (slot-value 'scale-type) 'variable)
           (send self :adjust-to-data :draw nil)))
        (setf (slot-value 'scale-type) new)
        (send self :adjust-to-data :draw draw))
  (slot-value 'scale-type))


(defmeth graph-proto :switch-use-color ()
  (send self :use-color (not (send self :use-color)))
  (send self :redraw)
  (send self :use-color))


(defmeth graph-proto :choose-mouse-mode ()
"Method args: ()
Presents a dialog to set the mouse mode."
  (let* ((modes (send self :mouse-modes))
         (modenow (position (send self :mouse-mode) modes))
         (m)
        )
    (if (> (length modes) 2)
        (setf m (choose-item-dialog "New Mode:"
                                (mapcar #'(lambda (x) 
                                            (send self :mouse-mode-title x))
                                        modes)
                                :initial modenow))
        (setf m (if (= modenow 0) 1 0)))
    (if m (send self :mouse-mode (nth m modes)))
    (send self :redraw)))


;------------------------------
;code for New Variable buttons
;-----------------------------

(defmeth graph-proto :new-x ()
  (send self :new-var "X" ))

(defmeth graph-proto :new-y ()
  (send self :new-var "Y" ))

(defmeth graph-proto :new-z ()
  (send self :new-var "Z" ))

(defmeth graph-proto :new-var (axis)
  (let* ((result (send self :new-variable-dialog axis))
         )
    (when (> (length result) 0)
          (setf result (select result 0))
          (cond 
            ((not result) (error-message "You must select a variable"))
            (t
             (send self :show-new-var axis result))))))


(defmeth graph-proto :new-variable-dialog (axis &optional current-vars)
"Arg: AXIS &OPTIONAL CUR-VARS
Presents a dialog box to choose a variable to be used on AXIS x y or z. Returns (var-name) for choice, (nil) for OK but no choice, nil for cancel."
  (unless current-vars (setf current-vars (send self :current-variables)))
  (let* ((row-pix 16)
         (variables (send self :variable-labels))
         (cur-vars current-vars)
         (last-cur-var (first (last cur-vars)))
         (show-variables (if current-vars
                             (send self :make-show-variables-list cur-vars)
                             (send self :make-show-variables-list)))
         (title (send text-item-proto :new 
                     (format nil "Choose new variable for ~a" axis)))
         (cancel (send modal-button-proto :new "Cancel"))
         (varlist nil)
         (ok (send modal-button-proto :new "OK" :action 
              #'(lambda () 
                  (let* ((selection (send varlist :selection))
                         )
                    (when selection
                          (setf selection 
                                (list (select show-variables selection))))
                    (when (not selection) (setf selection (list nil)))
                    selection))))
         (nshow nil)
         (dialog nil)
         (result nil))
    (when show-variables
          (setf nshow (length show-variables))
          (setf varlist 
                (if (> nshow 6) 
                    (send list-item-proto :new show-variables
                          :size (list 190 (* 6 row-pix)))
                    (send list-item-proto :new show-variables))))
    (cond
      ((not nshow) (setf result nil))
      ((= nshow 1) (setf result show-variables))
      ((> nshow 1)
       (setf dialog 
             (send modal-dialog-proto :new
                   (list title varlist (list ok cancel)) :default-button ok))
       (setf result (send dialog :modal-dialog))))
   result)) 


(defmeth graph-proto :make-show-variables-list (&optional cur-vars)
  (let* ((variables (combine (send self :variable-labels)))
         )
    (when (not cur-vars) (setf cur-vars (send self :current-variables)))
    (set-difference variables (select variables cur-vars))))


(defmeth graph-proto :replace-points (matrix labels symbols colors states)
"Method args: (coordinates labels symbols colors states)
Replaces current coordinates of points with new coordinates contained in the coordinates matrix.  Sets labels, symbols, colors and states with appropriate lists.  Forrest W. Young"
  (let ((n (send self :num-points))
        )
    (send self :transformation nil                 :draw nil)
    (send self :clear                              :draw nil)
    (send self :add-points  (column-list matrix)
               :point-labels labels                :draw nil)
    (send self :point-state (iseq n) states        :draw nil)
    (send self :point-symbol (iseq n) symbols      :draw nil)
    (send self :point-color (iseq n) colors        :draw nil)
    (send self :adjust-to-data)))

(defmeth graph-proto :subordinates (&optional (list nil set))
      (if set (setf (slot-value 'subordinates) list))
      (slot-value 'subordinates))

(defmeth graph-proto :select-all-points ()
  (send self :point-state (iseq (send self :num-points)) 'selected))

(defmeth graph-proto :add-rays 
  (rays &key ray-labels (ray-color 'black))
"Method args: (rays &key ray-labels ray-color)
Adds rays to spin-plot or scatterplot.  Rays are lines drawn from the center of the spin-plot to locations specified by RAYS, a list of sequences.  There must be one sequence for each dimension of the spin-plot.  The ray-ends are labled when RAY-LABELS, a list of strings, is used.  When RAY-LABELS is specified, the rays have points at their end, but not otherwise. The points can be selected to show the ray labels. Rays (and their points) are colored when RAY-COLOR, a color symbol, is used (black by default). Forrest W. Young"
  (when (not (send self :has-slot 'ray-line-width))
        (send self :add-slot 'ray-line-width 1)
        (defmeth self :ray-line-width (&optional (number nil set))
          (if set (setf (slot-value 'ray-line-width) number))
          (slot-value 'ray-line-width)))
  (let* ((ndim   (send self :num-variables))
         (nrays  (length (select rays 0)))
         (numoldlines (send self :num-lines))
         (numoldpoints (send self :num-points))
         (center (send self :center (iseq ndim)))
         (rays-matrix (transpose (matrix (list ndim nrays) (combine rays))))
         (line-matrix ()))
    (send self :use-color t)
    (dotimes (i nrays)
             (setf line-matrix 
              (matrix (list 2 ndim) 
                      (combine center (+ center (row rays-matrix i)))))
             (send self :add-lines (column-list line-matrix) 
                   :color ray-color :width (send self :ray-line-width)))
    (when ray-labels
          (send self :add-points 
                (column-list 
                 (+ rays-matrix 
                    (matrix (list nrays ndim) (combine 
                            (make-list nrays :initial-element center)))))
                :point-labels ray-labels
                )
          (send self :point-symbol
                (iseq numoldpoints (- (send self :num-points) 1)) 'dot1)
          (send self :point-color
                (iseq numoldpoints (- (send self :num-points) 1)) 
                ray-color)))
  nil)
